home *** CD-ROM | disk | FTP | other *** search
Text File | 2003-02-09 | 44.2 KB | 1,293 lines |
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- ; ** (c) Copyright 1982 Massachusetts Institute of Technology **
-
- ;(macsyma-module suprv)
-
- ;;note in converting this file (originally suprv.lisp) to common lisp
- ;;for the lisp machine, I removed a lot of the old stuff which did not
- ;;apply, and tried to eliminate any / quoting. Most of the relevant
- ;;stuff is in system.lisp for the lispm and nil friends.--wfs
-
- ;; #+MACLISP is ITS, Twenex, or Multics MacLisp.
- ;; #+PDP10 is ITS or Twenex MacLisp.
- ;; #+LISPM is the Lisp Machine or the Lisp Machine compiler running on ITS.
- ;; #+MACLISP and #+LISPM indicate which system a piece of code is intended
- ;; "for", not which system the code is being compiled "in".
- ;; #+GC means include gctime messages, and ok to call GCTWA here and there.
- ;; #-MAXII means not needed in new macsyma I/O and system organization.
-
- ;; Setting BASE to 10 at compile time needed for LAP to work.
-
-
- #-(or cl NIL)
- (EVAL-WHEN (EVAL COMPILE)
- (SETQ OLD-IBASE *read-base* OLD-BASE *print-base*)
- (SETQ *read-base* 10. *print-base* 10.))
- #+cl
- (EVAL-WHEN (EVAL COMPILE)
- (SETQ OLD-IBASE *READ-BASE* OLD-BASE *PRINT-BASE*)
- (SETQ *READ-BASE* 10. *PRINT-BASE* 10.))
-
- (defmvar mopl nil)
-
- (declare-top
- (SPECIAL M$+ GCFLAG GCT $LASTTIME $PARSETIME $DISPTIME
- BINDLIST LOCLIST ERRSET $LABELS LINELABLE $BATCOUNT $FILESIZE
- ST REPHRASE $DISPFLAG REFCHKL BAKTRCL RUBOUT TTYHEIGHT
- CNTLY NEWLINE DSKFNP DSKSAVEP *RSET CNTL@
- ^W ^R ^Q ^D LF TAB FF CNTLC ALT BATCONL CR VT ^H ^S BSP
- $VALUES $FUNCTIONS $ARRAYS $ALIASES $GRADEFS $DEPENDENCIES
- $RULES $PROPS $RATVARS $RATVARSWITCH DEBUG ERRBRKSW ERRCATCH
- VARLIST GENVAR $DEVICE $FILENAME $FILENUM LBP RBP
- $GENSUMNUM CHECKFACTORS $FEATURES FEATUREL $BACKTRACE
- $WEIGHTLEVELS TELLRATLIST $DONTFACTOR $INFOLISTS LOADFILES
- $DSKALL ERRLIST ALLBUTL LISPERRPRINT BACKRUB
- GC-DAEMON GC-OVERFLOW DEMONL $DYNAMALLOC ALLOCLEVEL INFILE
- ALARMCLOCK $C18MAXTIME $FILEID DCOUNT GCLINENUM THISTIME
- $NOLABELS $BATCHKILL DISPFLAG SAVENO MCATCH BRKLVL SAVEFILE
- STRING ST1 STIME0 $%% $ERROR
- *IN-$BATCHLOAD* *IN-TRANSLATE-FILE*
- LESSORDER GREATORDER $ERRORFUN MBREAK REPRINT POS $STRDISP
- $DSKUSE SMART-TTY RUBOUT-TTY MORE-^W OLDST ALPHABET
- $LOADPRINT TTYINTS OPERS
- *RATWEIGHTS $RATWEIGHTS QUITMSG MQUITMSG CONTMSG
- LOADF DISPLAY-FILE $GRIND SCROLLP $CURSORDISP
- STRINGDISP $LISPDISP MEXPRP DEFAULTF READING
- BPORG GCSYML ^AMSG ^BMSG ^HMSG
- STATE-PDL PROMPTMSG GCPROMPT COMMAND PRINTMSG MRG-PUNT
- NEW-C-LINE-HOOK TRANSP $CONTEXTS $SETCHECK $MACROS
- UNDF-FNCTN AUTOLOAD)
- #+CL (SPECIAL ERROR-CALL)
- #+Franz (special ptport display-to-disk)
- (*EXPR REPRINT)
- (*LEXPR CONCAT $FILEDEFAULTS $PRINT)
- (FIXNUM $FILESIZE DCOUNT $BATCOUNT I N N1 N2 TTYHEIGHT
- $FILENUM THISTIME GCT TIM GCLINENUM ALLOCLEVEL
- BRKLVL CMTCNT BPORG BPORG0 #-cl (COMPUTIME FIXNUM FIXNUM)
- #-cl (CASIFY FIXNUM) #-cl (GETLABCHARN))
- (FLONUM U1 STIME0)
- (NOTYPE (ASCII-NUMBERP FIXNUM))
- (ARRAY* (FIXNUM DISPLAY-FILE 1)))
-
-
- ;; This affects the runtime environment. ALJABR;LOADER also does this, but
- ;; leave it here for other systems. On the Lisp Machine, this is bound
- ;; per stack group.
-
- (defmvar $prompt
- '_
- nil
- no-reset)
-
- (eval-when (compile eval load)
-
- (defun control-char (ch)
- (code-char (+ (char-code #\) (- (char-code ch) (char-code #\A)))))
- )
-
- (PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPALIAS))
- '((+ $+) (- $-) (* $*) (// $//) (^ $^) (|.| |$.|) (< $<) (= $=)
- (> $>) (|(| |$(|) (|)| |$)|) (|[| |$[|) (|]| |$]|) (|,| |$,|) (|:| |$:|)
- (|!| |$!|) (|#| |$#|) (|'| |$'|) (|;| |$;|)))
- #+cl
- (MAPC #'(LAMBDA (X) (SET (CAR X)
- (cond (#-cl (< (cadr x)
- 160)
- #+cl (char< (cadr x)
- #. (code-char 160.))
- (ASCII (CADR X)))
- (t (cadr x)))))
- '( ;#-cl (CNTL@ #\)
- (CNTLC #. (control-char #\C))
- (BSP #\Backspace) (TAB #\TAB) (LF #\Linefeed)
- ; #-lispm (VT #\VT) ;;would not compile in lispmachine
- (FF #\Page) (CR #\return)
- (CNTLY #.(control-char #\Y))
- (SP #\Space)
- (NEWLINE #\NEWLINE) (RUBOUT #\RUBOUT)))
- (SETQ GCSYML NIL)
- (DOTIMES (I 14.) (PUSH (GENSYM) GCSYML))
- #-cl (SETQ ALT #-MULTICS (intern (string #\Escape)) #+MULTICS '&)
- #-CL (SETQ $PLOTUNDEFINED (*$ 2.0 -8.5070591E+37))
- (SETQ $LASTTIME '((MLIST) 0 0) THISTIME 0 GCT 0 GCFLAG NIL
- $PARSETIME NIL $DISPTIME NIL MEXPRP NIL)
- (SETQ BATCONL NIL $BATCOUNT 0 $BATCHKILL NIL $STRDISP T $GRIND NIL)
- (SETQ REFCHKL NIL DEBUG NIL BAKTRCL NIL ERRBRKSW NIL MBREAK NIL $ERRORFUN NIL
- ERRCATCH NIL DEMONL (LIST NIL) MCATCH NIL BRKLVL -1
- ALLBUTL NIL LOADF NIL $BACKTRACE '$BACKTRACE)
- (SETQ *IN-$BATCHLOAD* NIL *IN-TRANSLATE-FILE* NIL)
- (SETQ BACKRUB #-Franz nil #+Franz t)
- (SETQ $DEBUGMODE NIL $BOTHCASES T
- $PAGEPAUSE NIL $DSKGC NIL $POISLIM 5)
- (SETQ $LOADPRINT NIL ^S NIL LOADFILES NIL)
- ; (SETQ $FILEID NIL $C18MAXTIME 150.0E6)
- (SETQ $NOLABELS NIL $ALIASES '((MLIST SIMP)) LESSORDER NIL GREATORDER NIL)
- (SETQ $INFOLISTS
- (PURCOPY '((MLIST SIMP) $LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS
- $MYOPTIONS $PROPS $ALIASES $RULES $GRADEFS
- $DEPENDENCIES $LET_RULE_PACKAGES)))
- (SETQ $LABELS (list '(MLIST SIMP)))
- (setq $DSKUSE NIL $DEVICE '$DSK $DISPFLAG T LINELABLE NIL)
- (SETQ REPHRASE NIL ST NIL OLDST NIL REPRINT NIL POS NIL)
- (SETQ DCOUNT 0 $FILENUM 0 $STORENUM 1000. $FILESIZE 16. $DSKALL T
- NEW-C-LINE-HOOK NIL DSKFNP NIL TTYINTS T
- GCLINENUM 0 DSKSAVEP NIL SAVENO 0 $DYNAMALLOC NIL ALLOCLEVEL 0)
- (SETQ QUITMSG " "
- MQUITMSG " (Into LISP. Type control-G to get to MACSYMA.)"
- CONTMSG "(Type <space> to continue, <return> to terminate.)"
- ^AMSG " (Type EXIT; to exit.)"
- ^BMSG #-Multics "LISP (Type <Alt>P<Space> to continue.)"
- #+Multics "LISP (Type <Dollarsign>P<Carriage Return> to continue)"
- ^HMSG "
- (Use the RUBOUT or DEL(ETE) key to erase a character.)" ^DMSG-ON "
- (Printout of GC statistics turned on. Type control-D again to turn them off.)
- " ^DMSG-OFF "
- (Printout of GC statistics turned off.)
- " GCPROMPT "Type ALL; NONE; a level-no. or the name of the space.
- " MORE-^W NIL
- LISPERRPRINT T PRINTMSG NIL PROMPTMSG NIL MRG-PUNT NIL READING NIL)
- ; (SETQ $CALCOMPNUM 100.)
- (SETQ STATE-PDL (PURCOPY (NCONS 'LISP-TOPLEVEL)))
- #+MULTICS (SETQ $PLOT3DSIZE 20 $MULTGRAPH T)
- ; Slashify ':' on printout on other systems for the benefit of Lispm.
- ;;; Figure out how to do the above for Franz.
- '(Random properties))
-
- (DEFMVAR $% '$% "The last D-line computed, corresponds to lisp *" NO-RESET)
- (DEFMVAR $INCHAR '$C
- "The alphabetic prefix of the names of expressions typed by the user.")
- (DEFMVAR $OUTCHAR '$D
- "The alphabetic prefix of the names of expressions returned by the system.")
- (DEFMVAR $LINECHAR '$E
- "The alphabetic prefix of the names of intermediate displayed expressions.")
- (DEFMVAR $LINENUM 1 "the line number of the last expression." FIXNUM NO-RESET)
- (DEFMVAR $DIREC 'JRMU
- "The default file directory for SAVE, STORE, FASSAVE, and STRINGOUT."
- NO-RESET)
- (DEFMVAR CASEP T
- "Causes translation of characters from lower to upper case on ITS,
- and from upper to lower case on Multics and Franz.")
- ;(DEFMVAR $ERREXP '$ERREXP)
- (DEFMVAR USER-TIMESOFAR NIL)
-
-
-
- (DEFVAR MOREMSG "--Pause--")
- (DEFVAR MORECONTINUE "--Continued--")
- (DEFVAR MOREFLUSH NIL)
- (DEFMVAR $MOREWAIT NIL "needs to be documented" NO-RESET)
-
- (DEFMVAR $SHOWTIME NIL)
-
- (DEFMVAR ALIASLIST NIL
- "is used by the MAKEATOMIC scheme which has never been completed"
- NO-RESET)
-
- ;(declare-top (SETQ *print-base* 8))
-
-
- (DEFUN SYS-GCTIME ()
- #-Franz (STATUS GCTIME)
- #+Franz (cadr (ptime)))
-
-
- ;#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #\&)
-
- #-cl
- (DEFMVAR $CHANGE_FILEDEFAULTS #+PDP10 T #-PDP10 NIL
- "Does DDT-style file defaulting iff T")
-
- (DEFMVAR $FILE_STRING_PRINT #+PDP10 NIL #-PDP10 T
- "If TRUE, filenames are output as strings; if FALSE, as lists.")
-
- (DEFMVAR $SHOWTIME #-MULTICS NIL #+MULTICS T)
-
-
- (DEFMFUN MEVAL* (TEST)
- (LET (REFCHKL BAKTRCL CHECKFACTORS)
- (PROG2 (IF $RATVARSWITCH (SETQ VARLIST (CDR $RATVARS)))
- (MEVAL TEST)
- (CLEARSIGN))))
-
- (DEFMFUN MAKELABEL (X)
- (WHEN (AND $DSKUSE (NOT $NOLABELS) (> (SETQ DCOUNT (f1+ DCOUNT)) $FILESIZE))
- (SETQ DCOUNT 0) (DSKSAVE))
- (SETQ LINELABLE (CONCAT X $LINENUM))
- (IF (NOT $NOLABELS)
- (IF (OR (NULL (CDR $LABELS))
- (WHEN (MEMQ LINELABLE (CDDR $LABELS))
- (DELQ LINELABLE $LABELS 1) T)
- (NOT (EQ LINELABLE (CADR $LABELS))))
- (SETQ $LABELS (CONS (CAR $LABELS) (CONS LINELABLE (CDR $LABELS))))))
- LINELABLE)
-
- (DEFMFUN PRINTLABEL NIL
- (MTELL-OPEN "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE)))))
-
- (DEFMFUN MEXPLODEN (X)
- (let ( #-cl(*nopoint t) #+cl *print-radix*
- #+cl (*print-base* 10)
- #+NIL (si:standard-output-radix 10) #-(or cl NIL) (*print-base* 10))
- (EXPLODEN X)))
-
- (DEFMFUN ADDLABEL (LABEL)
- (SETQ $LABELS (CONS (CAR $LABELS) (CONS LABEL (DELQ LABEL (CDR $LABELS) 1)))))
-
- (DEFMFUN TYI* NIL
- #+Multics (CLEAR-INPUT NIL)
- (DO ((N (TYI) (TYI))) (NIL)
- (COND ((OR (char= N #\NewLine) (AND (> N 31) (NOT (char= N #\RUBOUT))))
- (RETURN N))
- ((char= N #\Page) (FORMFEED) (PRINC (STRIPDOLLAR $PROMPT))))))
-
- (DEFUN CONTINUEP NIL
- (PRINC (STRIPDOLLAR $PROMPT))
- (char= (TYI*) #-Multics #\Space #+Multics #\NewLine))
-
- (DEFUN CHECKLABEL (X) ; CHECKLABEL returns T iff label is not in use
- (NOT (OR $NOLABELS (= $LINENUM 0) (BOUNDP (CONCAT X $LINENUM)))))
-
- (DEFUN GCTIMEP (TIMEP TIM)
- (COND ((AND (EQ TIMEP '$ALL) (NOT (ZEROP TIM))) (PRINC "Totaltime= ") T)
- (T (PRINC "Time= ") NIL)))
-
- ;; If $BOTHCASES is T, lower case letters will not be converted to upper case.
-
- (DEFMFUN $BOTHCASES (X) (BOTHCASES1 NIL X))
-
- (DEFUN BOTHCASES1 (SYMBOL VALUE)
- SYMBOL ;Always bound to $BOTHCASES. Ignored.
- ;; This won't work with the Lisp Machine reader.
- #+MacLisp (DO ((I 97. (f1+ I))) ((> I 122.))
- (SETSYNTAX I (IF VALUE 1 321.) (IF VALUE I (f- I 32.))))
- (SETQ CASEP (NOT VALUE)) VALUE)
-
- ;(DEFUN BACKSPACE1 (NIL X)
- ; (COND (X (ADD2LNC 8 ALPHABET)
- ; (SETSYNTAX 8 322. NIL))
- ; (T (DELETE 8 ALPHABET 1)
- ; (SETSYNTAX 8 131392. NIL)))
- ; (SETQ BSPP X))
-
- #+CL
- (DEFUN LISTEN () 0) ; Doesn't exist yet.
-
- (DEFUN DISPLAY* (&AUX (RET NIL) (TIM 0))
- #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC)))
- (SETQ TIM (RUNTIME)
- RET (LET ((ERRSET 'ERRBREAK2) (THISTIME -1))
- (ERRSET (DISPLA (LIST '(MLABLE) LINELABLE $%)))))
- (IF (NULL RET) (MTELL "~%Error during display~%"))
- (IF $DISPTIME (MTELL-OPEN "Displaytime= ~A msec.~%" (COMPUTIME (RUNTIME) TIM)))
- RET)
-
-
- (DEFMFUN RUBOUT* (STG)
- (LET (#.TTYOFF #.WRITEFILEP)
- (COND (RUBOUT-TTY
- (COND ((OR REPRINT (NULL STG)
- (char= (CAR STG) #\return) (char= (CAR STG) #\tAB))
- (COND (SMART-TTY
- (CURSORPOS (CAR POS) (CDR POS)) (CURSORPOS 'L)
- (IF (CDR STG) (PRINC (MAKNAM (REVERSE (CDR STG)))))
- (SETQ REPRINT NIL))
- ((OR REPRINT STG) (REPRINT (CDR STG) NIL))))
- (T (CURSORPOS 'X))))
- (STG (TYO (CAR STG))))))
-
-
- (DEFMFUN REPRINT (STG FFP)
- (LET (#.TTYOFF #.WRITEFILEP)
- (IF (NOT FFP) (MTERPRI))
- (CASE (CAR STATE-PDL)
- (MACSYMA-TOPLEVEL (PRINTLABEL))
- (RETRIEVE (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT)))))
- (SETQ POS (CURSORPOS))
- (IF STG (PRINC (MAKNAM (REVERSE STG))))
- (SETQ REPRINT NIL)))
-
- ;; The PDP10 is one of the only systems which autoload.
- ;; The definition for non-autoloading systems is in MAXMAC. - CWH
- ;; For now we'll let a USER put autoload properties on symbols
- ;; and at least let them get found on Multics. - Jim 3/24/81
- ;; Franz also autoloads -- jkf
- ;;
-
- #+cl
- (defun generic-autoload (file &aux type)
- (setq file (pathname (cdr file)))
- (setq type (pathname-type file))
- (cond ((MEMBER type
- '(nil "BIN" "O" "o" "XFASL" "QFASL" "LISP" "LSP") :test 'equalp)
- (load file))
- (t ($batchload file))))
- #+cl
- (defvar autoload 'generic-autoload)
-
-
- #+(or Franz MACLISP NIL cl)
- (DEFMFUN LOAD-FUNCTION (FUNC MEXPRP) ; The dynamic loader
- (LET ((FILE (GET FUNC 'AUTOLOAD)))
- (IF FILE (FUNCALL AUTOLOAD (CONS FUNC FILE)))))
-
- (DEFMFUN LOAD-FILE (FILE) ($LOAD (TO-MACSYMA-NAMESTRING FILE)))
-
- (DEFMSPEC $LOADFILE (FORM)
- (LOADFILE (FILESTRIP (CDR FORM)) NIL
- (NOT (MEMQ $LOADPRINT '(NIL $AUTOLOAD)))))
-
-
-
- #-(or Franz cl cl)
- (DEFMSPEC $SETUP_AUTOLOAD (L)
- (SETQ L (CDR L))
- (show l)
- (IF (NULL (CDR L)) (WNA-ERR '$SETUP_AUTOLOAD))
- (LET ((FILE #-PDP10 ($FILE_SEARCH ($FILENAME_MERGE
- (CAR L)
- (USER-WORKINGDIR-PATHNAME)))
- #+PDP10 (NAMELIST (MERGEF ($FILENAME_MERGE (CAR L))
- `((DSK ,(STATUS UDIR)) NOFILE)))))
- (DOLIST (FUNC (CDR L))
- (NONSYMCHK FUNC '$SETUP_AUTOLOAD)
- (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD)
- (ADD2LNC FUNC $PROPS)))
- '$DONE)
- #+cl
- (DEFun $SETUP_AUTOLOAD (filename &rest functions)
- (LET ((FILE (string-trim "&$" filename)))
- (DOLIST (FUNC functions)
- (NONSYMCHK FUNC '$SETUP_AUTOLOAD)
- (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD)
- (ADD2LNC FUNC $PROPS)))
- '$DONE)
-
- (DEFMFUN DOLLARIFY (L)
- (LET ((ERRSET 'ERRBREAK1))
- (CONS '(MLIST SIMP)
- (MAPCAR #'(LAMBDA (X)
- (LET (Y)
- (COND ((NUMBERP X) X)
- ((NUMBERP (SETQ Y (CAR (ERRSET
- (READLIST
- (MEXPLODEN X))
- NIL))))
- Y)
- (T (MAKEALIAS X)))))
- L))))
-
- (DEFMFUN MFBOUNDP (FUNC)
- (OR (MGETL FUNC '(MEXPR MMACRO))
- (GETL FUNC '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S))))
-
- (DEFMFUN FILENAMEL (FILE)
- (COND ((ATOM FILE) (SETQ FILE (NCONS FILE)))
- (($LISTP FILE) (SETQ FILE (CDR FILE)))
- (T (MERROR "Not a proper filename ~M" FILE)))
- (FILESTRIP FILE))
-
-
-
- #+CL ; This is quite different from the Maclisp version.
- (DEFMFUN LOADFILE (FILE FINDP PRINTP &AUX (SAVENO 0))
- (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL))
- ;; Should really get the truename of FILE.
- (IF PRINTP (FORMAT T "~%~A being loaded.~%" FILE))
- (let* ((path (pathname FILE))
- (tem (errset (LOAD (pathname FILE)))))
- (or tem (merror "Load failed for ~A" (namestring path)))
- (namestring path)))
-
- (defun $directory (path)
- (cons '(mlist) (mapcar 'namestring (directory ($filename_merge path))))
- )
-
- (DEFMFUN TRUEFNAME (FILE)
- (OR (PROBE-FILE FILE)
- #-cl (CLOSE (OPEN FILE '(IN FIXNUM)))
- ; The OPEN is to generate the appropriate error handling.
- ; The CLOSE is just to be nice.
- #+Multics FILE
- ; The Multics CLOSE function returns T always.
- ; At least we know we can open and close the file.
- ; On Multics PROBE-FILE calls ALLFILES which demands access to
- ; the directory.
- ))
-
-
- #+CL
- (DEFMFUN MTRUENAME (STREAM)
- (MFILE-OUT (UNEXPAND-PATHNAME (FUNCALL STREAM ':NAME))))
-
- (DEFMFUN CARFILE (FILE) ; FILE is in OldIO list format.
- (IF (= (LENGTH FILE) 3) (CDR FILE) FILE))
-
- ;; SPECP is T if the file is being batched for TRANSL, or $LOAD,
- ;; or some other special purpose.
- #-Franz
- (DEFMACRO FILEPOS-CHECK () `(IF SPECP (SETQ FILEPOS (FILEPOS FILE-OBJ))))
-
-
- (DEFMSPEC $KILL (FORM) (MAPC #'KILL1 (CDR FORM)) #+GC (GCTWA) '$DONE)
-
- (defvar $dont_kill_symbols_with_lisp_source_files t "Prevents killing functional properties
- of items which have been translated and loaded")
-
- (DEFMFUN KILL1 (X)
- (funcall #'(LAMBDA (Z)
- (COND ((AND ALLBUTL (MEMQ X ALLBUTL)))
- ((EQ (SETQ X (GETOPR X)) '$LABELS)
- (DOLIST (U (CDR $LABELS))
- (COND ((AND ALLBUTL (MEMQ U ALLBUTL))
- (SETQ Z (NCONC Z (NCONS U))))
- (T (MAKUNBOUND U) (REMPROP U 'TIME)
- (REMPROP U 'NODISP))))
- (SETQ $LABELS (CONS '(MLIST SIMP) Z) $LINENUM 0 DCOUNT 0))
- ((MEMQ X '($VALUES $ARRAYS $ALIASES $RULES $PROPS $LET_RULE_PACKAGES))
- (MAPC #'KILL1 (CDR (SYMBOL-VALUE X))))
- ((MEMQ X '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES))
- (MAPC #'(LAMBDA (Y) (KILL1 (CAAR Y))) (CDR (SYMBOL-VALUE X))))
- ((EQ X '$MYOPTIONS))
- ((EQ X '$TELLRATS) (SETQ TELLRATLIST NIL))
- ((EQ X '$RATWEIGHTS) (SETQ *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP))))
- ((EQ X '$FEATURES)
- (COND ((NOT (EQUAL (CDR $FEATURES) FEATUREL))
- (SETQ $FEATURES (CONS '(MLIST SIMP) (copy-top-level FEATUREL ))))))
- ((OR (EQ X T) (EQ X '$ALL))
- (MAPC #'KILL1 (CDR $INFOLISTS))
- (SETQ $RATVARS '((MLIST SIMP)) VARLIST NIL GENVAR NIL
- CHECKFACTORS NIL GREATORDER NIL LESSORDER NIL $GENSUMNUM 0
- $WEIGHTLEVELS '((MLIST)) *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP))
- TELLRATLIST NIL $DONTFACTOR '((MLIST)) $SETCHECK NIL)
- (KILLALLCONTEXTS))
- ((SETQ Z (ASSQ X '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR)
- ($ELABELS . $LINECHAR))))
- (MAPC #'(LAMBDA (Y) (REMVALUE Y '$KILL)) (GETLABELS* (EVAL (CDR Z)) NIL)))
- ((AND (EQ (ml-typep X) 'fixnum) (NOT (< X 0))) (REMLABELS X))
- ((and $dont_kill_symbols_with_lisp_source_files
- (symbolp x)(or (get x 'translated)
- (and (fboundp x)
- (compiled-function-p
- (symbol-function x))))))
- ((ATOM X)
- (SETQ Z (OR (AND (MEMQ X (CDR $ALIASES)) (GET X 'NOUN)) (GET X 'VERB)))
- (COND ((OR (NULL ALLBUTL) (NOT (MEMQ Z ALLBUTL)))
- (REMVALUE X '$KILL) (REMCOMPARY X)
- (IF (MEMQ X (CDR $CONTEXTS)) ($KILLCONTEXT X))
- (IF (MGET X '$RULE)
- (LET ((Y (RULEOF X)))
- (COND (Y ($REMRULE Y X))
- (T #+MACLISP (REMPROP X 'EXPR)
- #-MACLISP (FMAKUNBOUND X)
- (DELQ X $RULES 1)))))
- (IF (AND (GET X 'OPERATORS) (RULECHK X)) ($REMRULE X '$ALL))
- (IF (MGET X 'TRACE) (MACSYMA-UNTRACE X))
- (WHEN (GET X 'TRANSLATED)
- (REMOVE-TRANSL-FUN-PROPS X)
- (REMOVE-TRANSL-ARRAY-FUN-PROPS X))
- (IF (NOT (GET X 'SYSCONST)) (REMPROP X 'MPROPS))
- (DOLIST (U '(BINDTEST NONARRAY EVFUN EVFLAG OPERS SPECIAL MODE))
- (REMPROP X U))
- (DOLIST (U OPERS)
- (IF (AND (REMPROP X U)
- (EQ (GET X 'OPERATORS) 'SIMPARGS1))
- (REMPROP X 'OPERATORS)))
- (WHEN (MEMQ X (CDR $PROPS))
- (REMPROP X 'SP2) (KILLFRAME X)
- (LET ((Y (STRIPDOLLAR X)))
- (REMPROP Y 'ALPHABET) (zl-DELETE (GETCHARN Y 1) ALPHABET 1)))
- (LET ((Y (GET X 'OP)))
- (IF (AND Y (NOT (MEMQ Y MOPL)) (MEMQ Y (CDR $PROPS)))
- (KILL-OPERATOR X)))
- (REMALIAS X NIL) (DELQ X $ARRAYS 1) (REMPROPCHK X)
- #+MACLISP (ARGS X NIL)
- (zl-DELETE (zl-ASSOC (NCONS X) $FUNCTIONS) $FUNCTIONS 1)
- (zl-DELETE (zl-ASSOC (NCONS X) $MACROS) $MACROS 1)
- (LET ((Y (zl-ASSOC (NCONS X) $GRADEFS)))
- (WHEN Y (REMPROP X 'GRAD) (zl-DELETE Y $GRADEFS 1)))
- (zl-DELETE (zl-ASSOC (NCONS X) $DEPENDENCIES) $DEPENDENCIES 1)
- (IF Z (KILL1 Z)))))
- ((AND (EQ (CAAR X) 'MLIST) (EQ (ml-typep (CADR X)) 'fixnum)
- (OR (AND (NULL (CDDR X)) (SETQ X (APPEND X (NCONS (CADR X)))))
- (AND (EQ (ml-typep (CADDR X)) 'fixnum) (NOT (> (CADR X) (CADDR X))))))
- (LET (($LINENUM (CADDR X))) (REMLABELS (f- (CADDR X) (CADR X)))))
- ((SETQ Z (MGETL (CAAR X) '(HASHAR ARRAY))) (REMARRELEM Z X))
- ((AND (EQ (CAAR X) '$ALLBUT)
- (NOT (DOLIST (U (CDR X)) (IF (NOT (SYMBOLP U)) (RETURN T)))))
- (LET ((ALLBUTL (CDR X))) (KILL1 T)))
- (T (IMPROPER-ARG-ERR X '$KILL))))
- NIL))
-
-
- (DEFMFUN REMLABELS (N)
- (PROG (L X)
- (SETQ L (LIST (EXPLODEN $INCHAR) (EXPLODEN $OUTCHAR) (EXPLODEN $LINECHAR)))
- LOOP (SETQ X (MEXPLODEN $LINENUM))
- (DO ((L L (CDR L)))( (NULL L)) (REMVALUE (IMPLODE (APPEND (CAR L) X)) '$KILL))
- (IF (OR (MINUSP (SETQ N (f1- N))) (= $LINENUM 0)) (RETURN NIL))
- (SETQ $LINENUM (f1- $LINENUM))
- (GO LOOP)))
-
- (DEFMFUN REMVALUE (X FN)
- (COND ((NOT (SYMBOLP X)) (IMPROPER-ARG-ERR X FN))
- ((BOUNDP X)
- (LET (Y)
- (COND ((OR (SETQ Y (MEMQ X (CDR $VALUES))) (MEMQ X (CDR $LABELS)))
- (COND (Y (DELQ X $VALUES 1))
- (T (DELQ X $LABELS 1)
- (REMPROP X 'TIME) (REMPROP X 'NODISP)
- (IF (NOT (ZEROP DCOUNT)) (SETQ DCOUNT (f1- DCOUNT)))))
- (MAKUNBOUND X) T)
- ((GET X 'SPECIAL) (MAKUNBOUND X) T)
- (TRANSP (SET X X) T)
- ((EQ X '$DEFAULT_LET_RULE_PACKAGE) T)
- (T (MTELL "Warning: Illegal REMVALUE attempt:~%~M" X) NIL))))))
-
- (DEFMFUN RULEOF (RULE)
- (OR (MGET RULE 'RULEOF)
- (LET ((OP (CAAADR (MGET RULE '$RULE))) L)
- (AND (SETQ L (GET OP 'RULES)) (MEMQ RULE L) OP))))
-
- (DEFMFUN $DEBUGMODE (X) (DEBUGMODE1 NIL X))
-
-
- #-NIL
- (DEFUN DEBUGMODE1 (ASSIGN-VAR Y)
- ASSIGN-VAR ; ignored
- #+MACLISP (SETQ DEBUG (COND (Y (*RSET T) Y) (T (*RSET NIL))))
- #+Franz (prog2 (setq debug y) (debugging y))
- #+akcl (if (eq y '$lisp) (si::use-fast-links y))
- #+cl (SETQ DEBUG (SETQ *RSET Y)))
-
- #+cl
- (defun retrieve1 (a b &aux (eof '(nil)))
- (let ((*mread-prompt* b) r )
- (declare (special *mread-prompt*))
- (catch 'macsyma-quit
- (tagbody
- top
- (SETQ R (dbm-read (or a *terminal-io*) nil eof))
- (cond ((and (consp r) (keywordp (car r)))
- (let ((value (break-call (car r) (cdr r) 'break-command)))
- (if (eq value :resume) (return-from retrieve1 '$exit))
- (go top))))
-
- )
- )
- (nth 2 r)
- ))
-
- #-NIL
- (DEFMFUN ERRBREAK (Y) ; The ERRSET interrupt function
- (COND
- (DEBUG
- ((LAMBDA (BRKLVL VARLIST GENVAR ERRBRKL LINELABLE)
- (declare (special $help))
- (PROG (X ^Q #.TTYOFF O^R #+MACLISP ERRSET #+LISPM ERROR-CALL TIM $%%
- #+Franz errset
- $BACKTRACE RETVAL OLDST ($help $help))
- #+ (or franz maclisp cl)
- (SETQ ERRSET 'ERRBREAK1)
- #+LISPM (setq ERROR-CALL 'ERRBREAK1)
- (SETQ TIM (RUNTIME) $%% '$%%
- ;; just in case baktrcl is cons'd on the stack
- $BACKTRACE (CONS '(MLIST SIMP) (copy-list BAKTRCL)))
- (SETQ O^R #.WRITEFILEP #.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP)))
- (cond ((eq y 'noprint))
- (t
- (MTERPRI)
- (IF Y (PRINC 'MACSYMA-BREAK) (PRINC 'ERROR-BREAK))
- (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL))
- (PRINC " Type EXIT; to quit, HELP; for more help.")))
- (setq $help
- "BACKTRACE; will give a successive list of forms
- (you must have already set ?DEBUG:ALL; for BACKTRACE to record)
- LISP; goes to lisp
- TOPLEVEL; goes all the way to top level
- EXIT; exits one level of the error break")
- (MTERPRI)
- A (COND
- ((NULL
- (CATCH 'MACSYMA-BREAK
- (LET ((STATE-PDL (CONS 'MACSYMA-BREAK STATE-PDL)))
- (ERRSET
- (COND ((EQ (SETQ X
- (RETRIEVE1 NIL
- (if y "_ " "(debug) "
- ))) '$EXIT)
- (TIMEORG TIM)
- (SETQ RETVAL 'EXIT) (GO END))
- ((EQ X '$LISP)
- #+MACLISP (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL)))
- (*BREAK T 'LISP) (MTERPRI)) ; ^B also works
- (SETQ RETVAL 'LISP)
- (GO END))
- ((EQ X '$TOPLEVEL)
- (COND ((CATCH 'MBREAK
- (LET (ST OLDST REPHRASE
- (MBREAK (CONS BINDLIST LOCLIST)))
- (SETQ $LINENUM (f1+ $LINENUM))
- (CONTINUE)))
- (GO END))
- (T (MTELL-OPEN "Back to the break~%"))))
- (T (LET (($DISPFLAG DISPFLAG)) (SETQ $%% (MEVAL X)))
- (IF DISPFLAG (DISPLA $%%) (MTERPRI))))))))
- (ERRLFUN1 ERRBRKL)
- (MTELL-OPEN "~%(Still in break loop)~%")))
- (GO A)
- END (unless (eq y 'noprint)
- (PRINC "Exited from the break ")
- (IF (NOT (ZEROP BRKLVL)) (PRINC BRKLVL))
- (MTERPRI)
- )
- (IF O^R (SETQ #.WRITEFILEP T))
- #+(or Franz MACLISP) (RETURN NIL) #+cl (RETURN RETVAL)))
- (f1+ BRKLVL) VARLIST GENVAR (CONS BINDLIST LOCLIST) LINELABLE))))
-
- #-NIL
- (DEFUN ERRBREAK1 (IGN) IGN NIL) ; Used to nullify ERRSETBREAKs
-
- #-NIL
- (DEFUN ERRBREAK2 (IGN) ign
- ; An alternate ERRSET interr. function; used by PARSE and DISPLAY
- #-cl IGNORE ; ignored
- (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) (*BREAK ERRBRKSW 'ERST)))
-
-
- ;; The ^B interrupt function
- (DEFUN MPAUSE (X)
- X ;Ignored
- (LET ((STATE-PDL (LIST* 'LISP-BREAK '^B-BREAK STATE-PDL))
- (MOREMSG "--Pause--"))
- #+PDP10 (ENDPAGEFN T 'MORE-FUN)
- #+PDP10 (BUFFCLEAR NIL)
- (TIMESOFAR T)
- #+MACLISP (NOINTERRUPT NIL)
- (*BREAK T ^BMSG))
- #+PDP10 (TTYRETFUN T))
-
-
-
- (DEFMSPEC $TOBREAK (X)
- (IF MBREAK (THROW 'MBREAK (CDR X))
- (MERROR "TOBREAK may be used only within a MACSYMA break.")))
-
- (DEFUN ERRLFUN (X)
- (WHEN (NULL
- (ERRSET
- (PROGN #-LISPM (SETQ ^S NIL)
- #+PDP10 (CLOSE SAVEFILE)
- #-LISPM (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL))
- #+PDP10 (ENDPAGEFN T 'MORE-FUN))))
- #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered."))
- (IF $ERRORFUN (IF (NULL (ERRSET (MAPPLY1 $ERRORFUN NIL $ERRORFUN nil)))
- (MTELL "~%Incorrect ERRORFUN")))
- (WHEN (NULL
- (ERRSET
- (PROGN (IF (NOT (EQ X 'MQUIT)) (SUPUNBIND)) (CLEARSIGN))))
- #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered."))
- (WHEN (NULL X) (PRINC QUITMSG) (SETQ QUITMSG " ")))
-
- (DEFUN SUPUNBIND NIL
- (MUNBIND (REVERSE BINDLIST)) (DO NIL ((NULL LOCLIST)) (MUNLOCAL)))
-
- (DEFMFUN ERRLFUN1 (MPDLS)
- (DO ((L BINDLIST (CDR L)) (L1)) ((EQ L (CAR MPDLS)) (MUNBIND L1))
- (SETQ L1 (CONS (CAR L) L1)))
- (DO NIL ((EQ LOCLIST (CDR MPDLS))) (MUNLOCAL)))
-
- (DEFMFUN GETALIAS (X) (COND ((GET X 'ALIAS)) ((EQ X '$FALSE) NIL) (T X)))
-
- (DEFMFUN MAKEALIAS (X) (IMPLODE (CONS #\$ (EXPLODEN X))))
-
-
- ;; (DEFMSPEC $F (FORM) (SETQ FORM (FEXPRCHECK FORM)) ...)
- ;; makes sure that F was called with exactly one argument and
- ;; returns that argument.
-
- (DEFMFUN FEXPRCHECK (FORM)
- (IF (OR (NULL (CDR FORM)) (CDDR FORM))
- (MERROR "~:M takes just one argument." (CAAR FORM))
- (CADR FORM)))
-
- (DEFMFUN NONSYMCHK (X FN)
- (UNLESS (SYMBOLP X)
- (MERROR "The argument to ~:M must be a symbolic name:~%~M" FN X)))
-
- ;(DEFMFUN NONVARCHK (X FN FLAG 2NDP)
- ; (WHEN (OR (MNUMP X) (INTEGERP X) (AND FLAG (ATOM X) (CONSTANT X))
- ; (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MOPP1 (CAAR X))))
- ; (MERROR "Non-variable~Margument to ~:M: ~M"
- ; (IF 2NDP '|& 2nd | '|& |) FN X)))
-
- (DEFMFUN PRINL (L) (DOLIST (X L) (PRINC X) (TYO #\Space)))
-
- (DEFMFUN $PRINT N
- (IF (= N 0)
- '((MLIST SIMP))
- (LET ((L (LISTIFY N)))
- (DO ((L L (CDDR L)))( (NULL L)) (RPLACD L (CONS '| | (CDR L))))
- (DISPLA (SETQ PRINTMSG (CONS '(MTEXT) L)))
- (CADR (REVERSE L)))))
-
-
- (DEFMSPEC $PLAYBACK (X) (SETQ X (CDR X))
- (LET ((STATE-PDL (CONS 'PLAYBACK STATE-PDL)))
- (PROG (L L1 L2 NUMBP SLOWP NOSTRINGP INPUTP TIMEP GRINDP INCHAR LARGP)
- (SETQ INCHAR (GETLABCHARN $INCHAR))
- ; Only the 1st alphabetic char. of $INCHAR is tested
- (SETQ TIMEP $SHOWTIME GRINDP $GRIND)
- (DO ((X X (CDR X)))( (NULL X))
- (COND ((EQ (ml-typep (CAR X)) 'fixnum) (SETQ NUMBP (CAR X)))
- ((EQ (CAR X) '$ALL))
- ((EQ (CAR X) '$SLOW) (SETQ SLOWP T))
- ((EQ (CAR X) '$NOSTRING) (SETQ NOSTRINGP T))
- ((EQ (CAR X) '$GRIND) (SETQ GRINDP T))
- ((EQ (CAR X) '$INPUT) (SETQ INPUTP T))
- ((MEMQ (CAR X) '($SHOWTIME $TIME)) (SETQ TIMEP (OR TIMEP T)))
- ((MEMQ (CAR X) '($GCTIME $TOTALTIME)) (SETQ TIMEP '$ALL))
- ((SETQ L2 (LISTARGP (CAR X)))
- (SETQ L1 (NCONC L1 (GETLABELS (CAR L2) (CDR L2) NIL)) LARGP T))
- (T (IMPROPER-ARG-ERR (CAR X) '$PLAYBACK))))
- (COND ((AND LARGP (NULL NUMBP)) (GO LOOP))
- ((AND (SETQ L (CDR $LABELS)) (NOT $NOLABELS)) (SETQ L (CDR L))))
- (WHEN (OR (NULL NUMBP) (< (LENGTH L) NUMBP))
- (SETQ L1 (REVERSE L)) (GO LOOP))
- (DO ((I NUMBP (f1- I)) (L2)) ((ZEROP I) (SETQ L1 (NCONC L1 L2)))
- (SETQ L2 (CONS (CAR L) L2) L (CDR L)))
- LOOP (IF (NULL L1) (RETURN '$DONE))
- ((LAMBDA (ERRSET INCHARP)
- (ERRSET
- (COND ((AND (NOT NOSTRINGP) INCHARP)
- (LET ((LINELABLE (CAR L1))) (MTERPRI) (PRINTLABEL))
- (IF GRINDP (MGRIND (MEVAL1 (CAR L1)) NIL)
- (MAPC #'TYO (MSTRING (MEVAL1 (CAR L1)))))
- (IF (GET (CAR L1) 'NODISP) (PRINC '$) (PRINC '|;|))
- (MTERPRI))
- ((OR INCHARP
- (PROG2 (WHEN (AND TIMEP (SETQ L (GET (CAR L1) 'TIME)))
- (SETQ X (GCTIMEP TIMEP (CDR L)))
- (MTELL-OPEN "~A msec." (CAR L))
- #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." (CDR L)))
- (MTERPRI))
- (NOT (OR INPUTP (GET (CAR L1) 'NODISP)))))
- (MTERPRI) (DISPLA (LIST '(MLABLE) (CAR L1) (MEVAL1 (CAR L1)))))
- (T (GO A)))))
- 'ERRBREAK2 (char= (GETLABCHARN (CAR L1)) INCHAR))
- (IF (AND SLOWP (CDR L1) (NOT (CONTINUEP))) (RETURN '$TERMINATED))
- A (SETQ L1 (CDR L1))
- (GO LOOP))))
-
- (DEFUN LISTARGP (X)
- (LET (HIGH)
- (IF (AND ($LISTP X) (EQ (ml-typep (CADR X)) 'fixnum)
- (OR (AND (NULL (CDDR X)) (SETQ HIGH (CADR X)))
- (AND (EQ (ml-typep (SETQ HIGH (CADDR X))) 'fixnum)
- (NOT (> (CADR X) HIGH)))))
- (CONS (CADR X) HIGH))))
-
- (DEFMSPEC $ALIAS (FORM)
- (IF (ODDP (LENGTH (SETQ FORM (CDR FORM))))
- (MERROR "ALIAS takes an even number of arguments."))
- (DO ((L NIL (CONS (ALIAS (POP FORM) (POP FORM))
- L)))
- ((NULL FORM)
- `((MLIST SIMP),@(NREVERSE L)))))
-
- (DEFMFUN ALIAS (X Y)
- (COND ((NONSYMCHK X '$ALIAS))
- ((NONSYMCHK Y '$ALIAS))
- ((NOT (EQ (GETCHAR X 1) '$))
- (MERROR "-ed symbols may not be aliased. ~M" X))
- ((GET X 'REVERSEALIAS)
- (IF (NOT (EQ X Y))
- (MERROR "~M already is aliased." X)))
- (T (PUTPROP X Y'ALIAS)
- (PUTPROP Y (STRIPDOLLAR X) 'REVERSEALIAS)
- (ADD2LNC Y $ALIASES)
- Y)))
-
- (DEFMFUN REMALIAS (X &optional REMP)
- (LET ((Y (AND (OR REMP (MEMQ X (CDR $ALIASES))) (GET X 'REVERSEALIAS))))
- (COND ((AND Y (EQ X '%DERIVATIVE))
- (REMPROP X 'REVERSEALIAS) (DELQ X $ALIASES 1)
- (REMPROP '$DIFF 'ALIAS) '$DIFF)
- (Y (REMPROP X 'REVERSEALIAS) (REMPROP X 'NOUN) (DELQ X $ALIASES 1)
- (REMPROP (SETQ X (MAKEALIAS Y)) 'ALIAS) (REMPROP X 'VERB) X))))
-
- (DEFMFUN STRIPDOLLAR (X)
- (COND ((NOT (ATOM X))
- (COND ((AND (EQ (CAAR X) 'BIGFLOAT) (NOT (MINUSP (CADR X)))) (IMPLODE (FPFORMAT X)))
- (T (MERROR "Atomic arg required:~%~M" X))))
- ((NUMBERP X) X)
- ((NULL X) 'FALSE)
- ((EQ X T) 'TRUE)
- ((MEMQ (GETCHAR X 1) '($ % &))
- #-(or Franz NIL cl) (IMPLODE (CDR (EXPLODEN X)))
- #+cl (intern (subseq (string x) 1))
- #+NIL (intern (substring x 1))
- #+Franz (concat (substring x 2)) ;Nice start/end conventions.
- )
- (T X)))
-
- (DEFMFUN FULLSTRIP (X) (MAPCAR #'FULLSTRIP1 X))
-
- (DEFMFUN FULLSTRIP1 (X)
- (OR (AND (NUMBERP X) X)
- (GET X 'REVERSEALIAS)
- (LET ((U (ASSQR X ALIASLIST))) (IF U (IMPLODE (STRING*1 (CAR U)))))
- (STRIPDOLLAR X)))
-
- (DEFUN STRING* (X)
- (OR (AND (NUMBERP X) (EXPLODEN X))
- (LET ((U (ASSQR X ALIASLIST))) (IF U (STRING*1 (CAR U))))
- (STRING*1 X)))
-
- (DEFUN STRING*1 (X) (LET (STRINGDISP $LISPDISP) (MAKESTRING X)))
-
- (DEFUN MAKSTRING* (X)
- (SETQ X (STRING* X))
- (DO ((L X (CDR L)))( (NULL L)) (RPLACA L (ASCII (CAR L))))
- X)
-
- (DEFMFUN $NOUNIFY (X)
- (LET (Y U)
- (NONSYMCHK X '$NOUNIFY)
- (SETQ X (AMPERCHK X))
- (COND ((GET X 'VERB))
- ((GET X 'NOUN) X)
- ((OR (SETQ U (MEMQ (CAR (SETQ Y (EXPLODEC X))) '($ M)))
- (NOT (EQ (CAR Y) '%)))
- (SETQ Y (IMPLODE (CONS '% (IF U (CDR Y) Y))))
- (PUTPROP Y X 'NOUN) (PUTPROP X Y 'VERB))
- (T X))))
-
- (DEFMFUN $VERBIFY (X)
- (NONSYMCHK X '$VERBIFY)
- (SETQ X (AMPERCHK X))
- (COND ((GET X 'NOUN))
- ((AND (char= (GETCHARN X 1) #\%)
- (PROG2 ($NOUNIFY #+NIL (let ((s (copy-seq (symbol-name x))))
- (setf (schar s 0) #.(code-char #\$))
- (intern s))
- #-NIL (IMPLODE (CONS #\$ (CDR (EXPLODEN X)))))
- (GET X 'NOUN))))
- (T X)))
-
- ;(DEFMFUN AMPERCHK (NAME)
- ; (IF (char= (GETCHARN NAME 1) #\&)
- ; (OR (GET NAME 'OPR)
- ; #+NIL (intern (nstring-upcase (string-append "$" name)))
- ; #-NIL (IMPLODE (CONS #\$ (CASIFY-EXPLODEN NAME))))
- ; NAME))
-
- (DEFMFUN DOLLARIFY-NAME (NAME)
- (LET ((N (GETCHARN NAME 1)))
- (COND ((char= N #\&)
- (OR (GET NAME 'OPR)
- (LET ((NAMEL (CASIFY-EXPLODEN NAME)) AMPNAME DOLNAME)
- (COND ((GET (SETQ AMPNAME (IMPLODE (CONS #\& NAMEL))) 'OPR))
- (T (SETQ DOLNAME (IMPLODE (CONS #\$ NAMEL)))
- (PUTPROP DOLNAME AMPNAME 'OP)
- (PUTPROP AMPNAME DOLNAME 'OPR)
- (ADD2LNC AMPNAME $PROPS)
- DOLNAME)))))
- ((char= N #\%) ($VERBIFY NAME))
- (T NAME))))
-
- #-NIL
- (DEFMFUN $RANDOM N (APPLY #'RANDOM (LISTIFY N)))
-
-
- (DEFMSPEC $STRING (FORM)
- (SETQ FORM (STRMEVAL (FEXPRCHECK FORM)))
- (SETQ FORM (IF $GRIND (STRGRIND FORM) (MSTRING FORM)))
- (SETQ ST (REVERSE FORM) REPHRASE T)
- (IMPLODE (CONS #\& FORM)))
-
- (DEFMFUN MAKSTRING (X)
- (SETQ X (MSTRING X)) (DO ((L X (CDR L)))( (NULL L)) (RPLACA L (ASCII (CAR L)))) X)
-
- (DEFMFUN STRMEVAL (X)
- (COND ((ATOM X) (MEVAL1 X))
- ((MEMQ (CAAR X) '(MSETQ MDEFINE MDEFMACRO)) X)
- (T (MEVAL X))))
-
- (PROG1 '(ALIAS properties)
- (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS)
- (PUTPROP (CADR X) (CADDR X) 'REVERSEALIAS))
- '(($BLOCK MPROG BLOCK) ($LAMBDA LAMBDA LAMBDA)
- ($ABS MABS ABS) ($SUBST $SUBSTITUTE SUBST)
- ($GO MGO GO) ($SIGNUM %SIGNUM SIGNUM)
- ($RETURN MRETURN RETURN) ($FACTORIAL MFACTORIAL FACTORIAL)
- ($NOUUO NOUUO NOUUO) ($RSET *RSET RSET)
- ($IBASE *read-base* *read-base*) ($OBASE *print-base* OBASE) ($NOPOINT *NOPOINT NOPOINT)
- ($MODULUS MODULUS MODULUS) ($ZUNDERFLOW ZUNDERFLOW ZUNDERFLOW)
- ($TTYOFF #.TTYOFF TTYOFF) ($WRITEFILE_ON #.WRITEFILEP WRITEFILE_ON)
- ($MODE_DECLARE $MODEDECLARE MODE_DECLARE)))
- (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS))
- '(($RATCOEFF $RATCOEF) ($RATNUM $RATNUMER) ($TRUE T)
- ($BINOM %BINOMIAL) ($DERIVATIVE $DIFF) ($PROD $PRODUCT)
- ($BOTHCOEFF $BOTHCOEF))))
-
- (DEFMFUN AMPERCHK (NAME)
- " $AB ==> $AB,
- $aB ==> $aB,
- &aB ==> $AB,
- |aB| ==> |aB| "
- (IF (char= (GETCHARN NAME 1) #\&)
- (OR (GET NAME 'OPR)
- ;;note the nil version does something else
- #+ NIL
- (nstring-upcase (string-append "$" name))
- #-NIL(IMPLODE (CONS #\$ (CASIFY-EXPLODEN NAME))))
- NAME))
-
-
- #+cl
- (defun casify-exploden (x)
- (cond ((char= (getcharn x 1) #\&)
- (cdr (exploden (string-upcase (string x)))))
- (t (exploden x))))
- #-cl
- (DEFMFUN CASIFY-EXPLODEN (X)
- (SETQ X (EXPLODEN X))
- (IF (char= (CAR X) #\&) (MAPCAR #'CASIFY (CDR X)) (CDR X)))
-
- (DEFMSPEC $STRINGOUT (X) (SETQ X (CDR X))
- (LET (FILE MAXIMA-ERROR L1 TRUENAME)
- (SETQ FILE ($FILENAME_MERGE (CAR X)))
- (SETQ X (CDR X))
- (WITH-OPEN-FILE (SAVEFILE FILE :direction :output)
- (COND ((NULL
- (ERRSET
- (DO ((L X (CDR L)))( (NULL L))
- (COND ((MEMQ (CAR L) '($ALL $INPUT))
- (SETQ L (NCONC (GETLABELS* $INCHAR T) (CDR L))))
- ((EQ (CAR L) '$VALUES)
- (SETQ L (NCONC (MAPCAN
- #'(LAMBDA (X)
- (IF (BOUNDP X)
- (NCONS (LIST '(MSETQ) X (SYMBOL-VALUE X)))))
- (CDR $VALUES))
- (CDR L))))
- ((EQ (CAR L) '$FUNCTIONS)
- (SETQ L (NCONC (MAPCAR
- #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL))
- (CDR $FUNCTIONS))
- (MAPCAN
- #'(LAMBDA (X)
- (IF (MGET X 'AEXPR)
- (NCONS (CONSFUNDEF X T NIL))))
- (CDR $ARRAYS))
- (MAPCAR
- #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL))
- (CDR $MACROS))
- (CDR L))))
- ((SETQ L1 (LISTARGP (CAR L)))
- (SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L)))))
- (IF (NULL L) (RETURN NIL))
- (TERPRI SAVEFILE)
- (IF $GRIND (MGRIND (STRMEVAL (CAR L)) SAVEFILE)
- #-Franz (PRINC (MAKNAM (MSTRING (STRMEVAL (CAR L))))
- SAVEFILE)
- #+Franz (mapc #'(lambda (ch) (tyo ch savefile))
- (mstring (strmeval (car l)))))
- (IF (OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP))
- (TYO #\$ SAVEFILE)
- (TYO SEMI-COLON-CHAR SAVEFILE)))))
- (SETQ MAXIMA-ERROR T)))
- (SETQ TRUENAME (TRUENAME SAVEFILE))
- (TERPRI SAVEFILE))
- (IF MAXIMA-ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in STRINGOUT attempt")))
- (lisp::namestring TRUENAME)))
- (DEFMSPEC $LABELS (CHAR)
- (SETQ CHAR (FEXPRCHECK CHAR))
- (NONSYMCHK CHAR '$LABELS)
- (CONS '(MLIST SIMP) (NREVERSE (GETLABELS* CHAR NIL))))
-
- (DEFMFUN $%TH (X)
- (PROG (L OUTCHAR)
- (IF (OR (NOT (EQ (ml-typep X) 'fixnum)) (= X 0))
- (IMPROPER-ARG-ERR X '$%TH))
- (IF (> X 0) (SETQ X (f- X)))
- (IF (CDR $LABELS)
- (SETQ L (CDDR $LABELS) OUTCHAR (GETLABCHARN $OUTCHAR)))
- LOOP (IF (NULL L) (MERROR "Improper call to %TH"))
- (IF (AND (char= (GETLABCHARN (CAR L)) OUTCHAR) (= (SETQ X (f1+ X)) 0))
- ; Only the 1st alphabetic character of $OUTCHAR is tested.
- (RETURN (MEVAL (CAR L))))
- (SETQ L (CDR L))
- (GO LOOP)))
-
- (DEFMFUN GETLABELS (N1 N2 FLAG) ; FLAG = T for STRINGOUT, = NIL for PLAYBACK and SAVE.
- (DO ((I N1 (f1+ I)) (L1)
- (L (IF FLAG (LIST (EXPLODEN $INCHAR))
- (LIST (EXPLODEN $INCHAR) (EXPLODEN $LINECHAR)
- (EXPLODEN $OUTCHAR)))))
- ((> I N2) (NREVERSE L1))
- (DO ((L L (CDR L)) (X (MEXPLODEN I)) (Z)) ((NULL L))
- (IF (BOUNDP (SETQ Z (IMPLODE (APPEND (CAR L) X))))
- (SETQ L1 (CONS Z L1))))))
-
- (DEFMFUN GETLABELS* (CHAR FLAG) ; FLAG = T only for STRINGOUT
- (DO ((L (IF FLAG (CDDR $LABELS) (CDR $LABELS)) (CDR L))
- (CHAR (GETLABCHARN CHAR)) (L1))
- ((NULL L) L1)
- (IF (char= (GETLABCHARN (CAR L)) CHAR)
- ; Only the 1st alphabetic character is tested.
- (SETQ L1 (CONS (CAR L) L1)))))
-
- (DEFMFUN GETLABCHARN (LABEL)
- (LET ((CHAR (GETCHARN LABEL 2))) (IF (char= CHAR #\%) (GETCHARN LABEL 3) CHAR)))
- (DEFMSPEC $ERRCATCH (FORM)
- (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET)
- (IF (NULL (SETQ RET (LET (DEBUG)
- (ERRSET (MEVALN (CDR FORM)) LISPERRPRINT))))
- (ERRLFUN1 ERRCATCH))
- (CONS '(MLIST) RET)))
-
- ;(DEFMFUN $ERROR N ; Moved to MAXSRC;MERROR
- ; (LET ((MSG (LISTIFY N)))
- ; (IF (> N 0) (APPLY #'$PRINT MSG))
- ; (IF ERRCATCH (ERROR))
- ; (IF DEBUG (LET (($ERROR (CONS '(MLIST SIMP) (FSTRINGC MSG))))
- ; (ERRBREAK NIL)))
- ; (MQUIT T)))
-
-
- (DEFMSPEC $CATCH (FORM)
- (LET ((MCATCH (CONS BINDLIST LOCLIST)))
- (PROG1 (CATCH 'MCATCH (MEVALN (CDR FORM))) (ERRLFUN1 MCATCH))))
-
- (DEFMFUN $THROW (EXP)
- (IF (NULL MCATCH) (MERROR "THROW not within CATCH:~%~M" EXP))
- (THROW 'MCATCH EXP))
-
- (DEFMSPEC $TIME (L) (SETQ L (CDR L))
- #-cl
- (MTELL-OPEN "TIME or [TOTALTIME, GCTIME] in msecs.:~%")
- #+cl
- (format t "~&Time:")
- (CONS '(MLIST SIMP)
- (MAPCAR
- #'(LAMBDA (X)
- (OR (AND (SETQ X (OR (GET X 'TIME)
- (AND (EQ X '$%) (CONS (CADR $LASTTIME)
- (CADDR $LASTTIME)))))
- (IF (= (CDR X) 0)
- (CAR X)
- (LIST '(MLIST SIMP) (CAR X) (CDR X))))
- '$UNKNOWN))
- L)))
-
- (DEFMFUN TIMEORG (TIM)
- (IF (> THISTIME 0) (SETQ THISTIME (f+ THISTIME (f- (RUNTIME) TIM)))))
-
- ; Take difference of two times, return result in milliseconds.
- #+LISPM
- (DEFMFUN COMPUTIME (N1 N2) (// (f* 50. (TIME-DIFFERENCE
- N1 N2)) 3.))
-
-
- #+CL (PROGN 'COMPILE
- (DEFMFUN $QUIT () nil #+kcl (bye) #+cmu (ext:quit) #+sbcl (sb-ext:quit) #+clisp (ext:quit)
-
- (quit)
- #+excl "don't know quit function")
- (DEFMFUN $LOGOUT () (LOGOUT))
- )
- (DEFMFUN FILEPRINT (FNAME) ; Takes filename in NAMELIST format.
- (COND ($FILE_STRING_PRINT (PRINC (NAMESTRING FNAME)) (PRINC " "))
- (T (PRINC "[")
- (PRINC (CADR FNAME)) (PRINC ", ")
- (PRINC (CADDR FNAME)) (PRINC ", ")
- (WHEN (CDDDR FNAME) (PRINC (CADDDR FNAME)) (PRINC ", ")) ; For TOPS-20
- (PRINC (CAAR FNAME)) (PRINC ", ")
- (PRINC (CADAR FNAME)) (PRINC "] "))))
-
- (DEFMFUN MFILE-OUT (FNAME) ; Takes filename in NAMELIST or OldIO list format.
- (IF $FILE_STRING_PRINT
- (IMPLODE (CONS #\& (EXPLODEN (NAMESTRING FNAME))))
- (DOLLARIFY (IF (ATOM (CAR FNAME)) FNAME (APPEND (CDR FNAME) (CAR FNAME))))))
-
- ; File-processing stuff. Lisp Machine version in MC:LMMAX;LMSUP.
-
-
-
- (DEFUN MFILE NIL
- (FULLSTRIP (LIST $FILENAME (SETQ $FILENUM (f1+ $FILENUM)) $DEVICE $DIREC)))
-
-
- ;; This prevents single blank lines from appearing at the top of video
- ;; terminals. If at the upper left corner and we want to print a blank
- ;; line, leave the cursor there and send the blank line to transcript
- ;; files only.
-
- #+(OR PDP10 NIL CL)
- (DEFMFUN MTERPRI (&AUX X)
- #-nocp (setq x (CURSORPOS))
- (IF (AND SMART-TTY X (EQUAL X '(0 . 0)))
- (LET ((#.TTYOFF T)) (TERPRI))
- (TERPRI)))
-
- #+lispm
- (DECLARE-top (SPECIAL TV:MORE-PROCESSING-GLOBAL-ENABLE))
-
- #+LISPM
- (DEFMFUN MORE-FUN (FILE)
- FILE ;ignored
- (send *terminal-io* :send-if-handles :more-exception))
-
-
- #+LISPM
- (DEFUN MORE-FUN-INTERNAL (*terminal-io*
- &AUX (*standard-input* *terminal-io*))
- ;; 'SI:TERMINAL-IO-SYN-STREAM))
- ;; SI:SYN-TERMINAL-IO))
- ; This clears the rest of the screen, unless we're at the bottom
- ; or too close to the top.
- (COND ((NOT (OR (< (CAR (CURSORPOS)) 10.)
- (= (- TTYHEIGHT 2) (CAR (CURSORPOS)))))
- (CURSORPOS 'E)))
- ; Now go to the bottom of the screen and cause a more, unless disabled.
- (COND (TV:MORE-PROCESSING-GLOBAL-ENABLE
- (CURSORPOS 'Z) (CURSORPOS 'L)
- ((LAMBDA (^Q)
- ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL)
- (PRINC MOREMSG) (TYIPEEK)
- ; Now see what the user feels like typing in.
- (COND ($MOREWAIT
- (DO ((L (COND ((EQ $MOREWAIT '$ALL) '(#\SPACE #\RETURN))
- (T '(#\SPACE #\RETURN #\RUBOUT)))))
- ((zl-MEMBER (TYIPEEK) L))
- (TYI T))) ; eat other characters
- (T (DO () ((NOT (zl-MEMBER (TYIPEEK) '(4 19. 21. 22. 29.))))
- (TYI T)))) ; eat ^], etc.
- ; Now erase the MORE message
- (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS 'L)) (T (TERPRI))))
- NIL NIL (CONS 'MORE-WAIT STATE-PDL))
- ; Now decide whether to continue or flush
- (COND ((char= #\Space (TYIPEEK))
- (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE)))
- (TYI T)) ; eat the space
- ((char= #\RUBOUT (TYIPEEK))
- (LET ((#.TTYOFF T)) (TERPRI))
- (IF MOREFLUSH (PRINC MOREFLUSH))
- (TYI T) ; eat the rubout
- (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T))
- #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH))))
- (T (COND ((OR (MEMQ 'BATCH STATE-PDL)
- (AND (char< (TYIPEEK) #\SPACE)
- (NOT (zl-MEMBER (TYIPEEK)
- #.(cons 'list (mapcar 'code-char '(2 7 11. 12. 25. 27. 28. 29. 30.))))
- ; '(#\Alpha #\Pi
- ; #\Up-Arrow
- ; #\Plus-Minus
- ; #\Right-Arrow
- ; #\Lozenge
- ; #\Less-Or-Equal
- ; #\Greater-Or-Equal
- ; #\Equivalence)
- ))
- (char>= (TYIPEEK) #. (code-char 128.)))
- (TYI T))) ; eat cr or other control character.
- (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH)))
- (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T))))))
- NIL)))
- ; Now home up, or advance to next line, and continue display.
- (IF SMART-TTY
- (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS 'L)))
- (T (MAXIMA-SLEEP 0.4) (FORMFEED)))
- (LET (#.TTYOFF #.WRITEFILEP) (TERPRI))))
-
- (DEFMFUN $PAGEPAUSE (X) (PAGEPAUSE1 NIL X))
-
-
- #-PDP10
- (DEFUN PAGEPAUSE1 (X Y)
- X Y (MERROR "PAGEPAUSE does not exist in this system."))
-
-
- #+(or cl LISPM)
- (DEFMSPEC $STATUS (FORM)
- (setq form (cdr form))
- (LET* ((KEYWORD (car FORM))
- (FEATURE (cadr form)))
- (assert (symbolp keyword))
- (assert (symbolp feature))
- (CASE KEYWORD
- ($FEATURE (COND ((NULL FEATURE) (DOLLARIFY #-cl (STATUS FEATURES)
- #+cl *features*))
- ((MEMQ (intern (symbol-name
- (FULLSTRIP1 FEATURE)) 'keyword)
- #-cl(STATUS FEATURES)
- #+cl *features*
- ) T)))
- ($STATUS '((MLIST SIMP) $FEATURE $STATUS))
- (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD)))))
-
- #+(or cl lispm)
- (defquote $sstatus (status-function item)
- (cond ((equal status-function '$feature)
- (pushnew ($mkey item) *features*) t)
- ((equal status-function '$nofeature)
- (setq *features* (delete ($mkey item) *features*)) t)
- (t (error "know only how to set and remove feature status"))))
-
- ;; End of disk GC conditionalization.
-
- #-PDP10 (PROGN 'COMPILE
- (DEFMFUN $DSKGC (X) X NIL)
- (DEFUN DSKGC1 (X Y) X Y NIL)
- )
-
-
-
- #+CL (SETQ ERROR-CALL 'ERRBREAK)
-
- (PROGN (DO ((L '($SQRT $ERF $SIN $COS $TAN $LOG $PLOG $SEC $CSC $COT $SINH $COSH
- $TANH $SECH $CSCH $COTH $ASIN $ACOS $ATAN $ACOT $ACSC $ASEC $ASINH
- $ACOSH $ATANH $ACSCH $ASECH $ACOTH $BINOMIAL $GAMMA $GENFACT $DEL)
- (CDR L)))( (NULL L))
- ((LAMBDA (X)
- (PUTPROP (CAR L) X 'ALIAS)
- (PUTPROP X (STRIPDOLLAR (CAR L)) 'REVERSEALIAS))
- ($NOUNIFY (CAR L))))
- ($NOUNIFY '$SUM) ($NOUNIFY '$PRODUCT)
- ($NOUNIFY '$INTEGRATE) ($NOUNIFY '$LIMIT)
- (DEFPROP $DIFF %DERIVATIVE VERB) (DEFPROP %DERIVATIVE $DIFF NOUN)
- '(NOUN properties))
-
- (PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN))
- '(($DEBUGMODE DEBUGMODE1) ($BOTHCASES BOTHCASES1)
- ($PAGEPAUSE PAGEPAUSE1) ($DSKGC DSKGC1)
- ($TTYINTFUN TTYINTFUNSETUP)
- ($FPPREC FPPREC1) ($POISLIM POISLIM1)
- ($default_let_rule_package let-rule-setter)
- ($current_let_rule_package let-rule-setter)
- ($let_rule_packages let-rule-setter)))
- (MAPC #'(LAMBDA (X) (PUTPROP X 'NEVERSET 'ASSIGN)) (CDR $INFOLISTS))
- (DEFPROP $CONTEXTS NEVERSET ASSIGN)
- '(ASSIGN properties))
-
-
-
- ; Undeclarations for the file:
- (declare-top (NOTYPE I N N1 N2 U1))
-
- #-(or cl NIL)
- (EVAL-WHEN (EVAL COMPILE) (SETQ *print-base* OLD-BASE *read-base* OLD-IBASE))
- #+cl
- (EVAL-WHEN (EVAL COMPILE) (SETQ *PRINT-BASE* OLD-BASE *READ-BASE* OLD-IBASE))
-
- nil
-